home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / Console.tcl.z / Console.tcl
Encoding:
Text File  |  1999-01-26  |  12.0 KB  |  516 lines
  1. # Console.tcl --
  2. #
  3. #    This code constructs the console window for an application.
  4. #    It can be used by non-unix systems that do not have built-in
  5. #    support for shells.
  6. #
  7. #    This file was distributed as a part of Tk 4.1 by Sun
  8. #    Microsystems, Inc. and subsequently modified by Expert
  9. #    Interface Techonoligies and included as a part of Tix.
  10. #
  11. #    Some of the functions in this file have been renamed from
  12. #    using a "tk" prefix to a "tix" prefix to avoid namespace
  13. #    conflict with the original file.
  14. #
  15. # Copyright (c) 1995-1996 Sun Microsystems, Inc.
  16. # Copyright (c) 1996 Expert Interface Technologies.
  17. #
  18. # See the file "docs/license.tcltk" for information on usage and
  19. # redistribution of the original file "console.tcl". These license
  20. # terms do NOT apply to other files in the Tix distribution.
  21. #
  22. # See the file "license.terms" for information on usage and
  23. # redistribution * of this file, and for a DISCLAIMER OF ALL
  24. # WARRANTIES.
  25.  
  26. # tixConsoleInit --
  27. # This procedure constructs and configures the console windows.
  28. #
  29. # Arguments:
  30. #     None.
  31.  
  32. proc tixConsoleInit {} {
  33.     global tcl_platform
  34.  
  35.     uplevel #0 set tixConsoleTextFont Courier
  36.     uplevel #0 set tixConsoleTextSize 14
  37.  
  38.     set f [frame .f]
  39.     set fontcb [tixComboBox $f.size -label "" -command "tixConsoleSetFont" \
  40.     -variable tixConsoleTextFont \
  41.     -options {
  42.         entry.width    15
  43.         listbox.height 5
  44.     }]
  45.     set sizecb [tixComboBox $f.font -label "" -command "tixConsoleSetFont" \
  46.     -variable tixConsoleTextSize \
  47.     -options {
  48.         entry.width    4
  49.         listbox.width  6
  50.         listbox.height 5
  51.     }]
  52.     pack $fontcb $sizecb -side left
  53.     pack $f -side top -fill x -padx 2 -pady 2
  54.     foreach font {
  55.     "Courier New"
  56.     "Courier"
  57.     "Helvetica"
  58.     "Lucida"
  59.     "Lucida Typewriter"
  60.     "MS LineDraw"
  61.     "System"
  62.     "Times Roman"
  63.     } {
  64.     $fontcb subwidget listbox insert end $font
  65.     }
  66.  
  67.     for {set s 6} {$s < 25} {incr s} {
  68.     $sizecb subwidget listbox insert end $s
  69.     }
  70.  
  71.     bind [$fontcb subwidget entry] <Escape> "focus .console"
  72.     bind [$sizecb subwidget entry] <Escape> "focus .console"
  73.  
  74.     text .console  -yscrollcommand ".sb set" -setgrid true \
  75.     -highlightcolor [. cget -bg] -highlightbackground [. cget -bg] \
  76.     -cursor left_ptr
  77.     scrollbar .sb -command ".console yview" -highlightcolor [. cget -bg] \
  78.     -highlightbackground [. cget -bg]
  79.     pack .sb -side right -fill both
  80.     pack .console -fill both -expand 1 -side left
  81.  
  82.     tixConsoleBind .console
  83.  
  84.     .console tag configure stderr -foreground red
  85.     .console tag configure stdin -foreground blue
  86.  
  87.     focus .console
  88.     
  89.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  90.     wm title . "Console"
  91.     flush stdout
  92.     .console mark set output [.console index "end - 1 char"]
  93.     tkTextSetCursor .console end
  94.     .console mark set promptEnd insert
  95.     .console mark gravity promptEnd left
  96.  
  97.     tixConsoleSetFont
  98. }
  99.  
  100. proc tixConsoleSetFont {args} {
  101.     if ![winfo exists .console] tixConsoleInit
  102.  
  103.     global tixConsoleTextFont tixConsoleTextSize
  104.  
  105.     set font  -*-$tixConsoleTextFont-medium-r-normal-*-$tixConsoleTextSize-*-*-*-*-*-*-*
  106.     .console config -font $font
  107. }
  108.  
  109. # tixConsoleInvoke --
  110. # Processes the command line input.  If the command is complete it
  111. # is evaled in the main interpreter.  Otherwise, the continuation
  112. # prompt is added and more input may be added.
  113. #
  114. # Arguments:
  115. # None.
  116.  
  117. proc tixConsoleInvoke {args} {
  118.     if ![winfo exists .console] tixConsoleInit
  119.  
  120.     if {[.console dlineinfo insert] != {}} {
  121.     set setend 1
  122.     } else {
  123.     set setend 0
  124.     }
  125.     set ranges [.console tag ranges input]
  126.     set cmd ""
  127.     if {$ranges != ""} {
  128.     set pos 0
  129.     while {[lindex $ranges $pos] != ""} {
  130.         set start [lindex $ranges $pos]
  131.         set end [lindex $ranges [incr pos]]
  132.         append cmd [.console get $start $end]
  133.         incr pos
  134.     }
  135.     }
  136.     if {$cmd == ""} {
  137.     tixConsolePrompt
  138.     } elseif [info complete $cmd] {
  139.     .console mark set output end
  140.     .console tag delete input
  141.     set err [catch {
  142.         set result [interp record $cmd]
  143.     } result]
  144.  
  145.     if {$result != ""} {
  146.         if {$err} {
  147.         .console insert insert "$result\n" stderr
  148.         } else {
  149.         .console insert insert "$result\n"
  150.         }
  151.     }
  152.     tixConsoleHistory reset
  153.     tixConsolePrompt
  154.     } else {
  155.     tixConsolePrompt partial
  156.     }
  157.     if {$setend} {
  158.     .console yview -pickplace insert
  159.     }
  160. }
  161.  
  162. # tixConsoleHistory --
  163. # This procedure implements command line history for the
  164. # console.  In general is evals the history command in the
  165. # main interpreter to obtain the history.  The global variable
  166. # histNum is used to store the current location in the history.
  167. #
  168. # Arguments:
  169. # cmd -    Which action to take: prev, next, reset.
  170.  
  171. set histNum 1
  172. proc tixConsoleHistory {cmd} {
  173.     if ![winfo exists .console] tixConsoleInit
  174.  
  175.     global histNum
  176.     
  177.     switch $cmd {
  178.         prev {
  179.         incr histNum -1
  180.         if {$histNum == 0} {
  181.         set cmd {history event [expr [history nextid] -1]}
  182.         } else {
  183.         set cmd "history event $histNum"
  184.         }
  185.             if {[catch {interp eval $cmd} cmd]} {
  186.                 incr histNum
  187.                 return
  188.             }
  189.         .console delete promptEnd end
  190.             .console insert promptEnd $cmd {input stdin}
  191.         }
  192.         next {
  193.         incr histNum
  194.         if {$histNum == 0} {
  195.         set cmd {history event [expr [history nextid] -1]}
  196.         } elseif {$histNum > 0} {
  197.         set cmd ""
  198.         set histNum 1
  199.         } else {
  200.         set cmd "history event $histNum"
  201.         }
  202.         if {$cmd != ""} {
  203.         catch {interp eval $cmd} cmd
  204.         }
  205.         .console delete promptEnd end
  206.         .console insert promptEnd $cmd {input stdin}
  207.         }
  208.         reset {
  209.             set histNum 1
  210.         }
  211.     }
  212. }
  213.  
  214. # tixConsolePrompt --
  215. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  216. # exists in the main interpreter it will be called to generate the 
  217. # prompt.  Otherwise, a hard coded default prompt is printed.
  218. #
  219. # Arguments:
  220. # partial -    Flag to specify which prompt to print.
  221.  
  222. proc tixConsolePrompt {{partial normal}} {
  223.     if ![winfo exists .console] tixConsoleInit
  224.  
  225.     if {$partial == "normal"} {
  226.     set temp [.console index "end - 1 char"]
  227.     .console mark set output end
  228.         if [interp eval "info exists tcl_prompt1"] {
  229.             interp eval "eval \[set tcl_prompt1\]"
  230.         } else {
  231.             puts -nonewline "% "
  232.         }
  233.     } else {
  234.     set temp [.console index output]
  235.     .console mark set output end
  236.         if [interp eval "info exists tcl_prompt2"] {
  237.             interp eval "eval \[set tcl_prompt2\]"
  238.         } else {
  239.         puts -nonewline "> "
  240.         }
  241.     }
  242.  
  243.     flush stdout
  244.     .console mark set output $temp
  245.     tkTextSetCursor .console end
  246.     .console mark set promptEnd insert
  247.     .console mark gravity promptEnd left
  248. }
  249.  
  250. # tixConsoleBind --
  251. # This procedure first ensures that the default bindings for the Text
  252. # class have been defined.  Then certain bindings are overridden for
  253. # the class.
  254. #
  255. # Arguments:
  256. # None.
  257.  
  258. proc tixConsoleBind {win} {
  259.     if ![winfo exists .console] tixConsoleInit
  260.  
  261.     bindtags $win "$win Text . all"
  262.  
  263.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  264.     # Otherwise, if a widget binding for one of these is defined, the
  265.     # <KeyPress> class binding will also fire and insert the character,
  266.     # which is wrong.  Ditto for <Escape>.
  267.  
  268.     bind $win <Alt-KeyPress> {# nothing }
  269.     bind $win <Meta-KeyPress> {# nothing}
  270.     bind $win <Control-KeyPress> {# nothing}
  271.     bind $win <Escape> {# nothing}
  272.     bind $win <KP_Enter> {# nothing}
  273.  
  274.     bind $win <Tab> {
  275.     tixConsoleInsert %W \t
  276.     focus %W
  277.     break
  278.     }
  279.     bind $win <Return> {
  280.     %W mark set insert {end - 1c}
  281.     tixConsoleInsert %W "\n"
  282.     tixConsoleInvoke
  283.     break
  284.     }
  285.     bind $win <Delete> {
  286.     if {[%W tag nextrange sel 1.0 end] != ""} {
  287.         %W tag remove sel sel.first promptEnd
  288.     } else {
  289.         if [%W compare insert < promptEnd] {
  290.         break
  291.         }
  292.     }
  293.     }
  294.     bind $win <BackSpace> {
  295.     if {[%W tag nextrange sel 1.0 end] != ""} {
  296.         %W tag remove sel sel.first promptEnd
  297.     } else {
  298.         if [%W compare insert <= promptEnd] {
  299.         break
  300.         }
  301.     }
  302.     }
  303.     foreach left {Control-a Home} {
  304.     bind $win <$left> {
  305.         if [%W compare insert < promptEnd] {
  306.         tkTextSetCursor %W {insert linestart}
  307.         } else {
  308.         tkTextSetCursor %W promptEnd
  309.             }
  310.         break
  311.     }
  312.     }
  313.     foreach right {Control-e End} {
  314.     bind $win <$right> {
  315.         tkTextSetCursor %W {insert lineend}
  316.         break
  317.     }
  318.     }
  319.     bind $win <Control-d> {
  320.     if [%W compare insert < promptEnd] {
  321.         break
  322.     }
  323.     }
  324.     bind $win <Control-k> {
  325.     if [%W compare insert < promptEnd] {
  326.         %W mark set insert promptEnd
  327.     }
  328.     }
  329.     bind $win <Control-t> {
  330.     if [%W compare insert < promptEnd] {
  331.         break
  332.     }
  333.     }
  334.     bind $win <Meta-d> {
  335.     if [%W compare insert < promptEnd] {
  336.         break
  337.     }
  338.     }
  339.     bind $win <Meta-BackSpace> {
  340.     if [%W compare insert <= promptEnd] {
  341.         break
  342.     }
  343.     }
  344.     bind $win <Control-h> {
  345.     if [%W compare insert <= promptEnd] {
  346.         break
  347.     }
  348.     }
  349.     foreach prev {Control-p Up} {
  350.     bind $win <$prev> {
  351.         tixConsoleHistory prev
  352.         break
  353.     }
  354.     }
  355.     foreach prev {Control-n Down} {
  356.     bind $win <$prev> {
  357.         tixConsoleHistory next
  358.         break
  359.     }
  360.     }
  361.     bind $win <Control-v> {
  362.     if [%W compare insert > promptEnd] {
  363.         catch {
  364.         %W insert insert [selection get -displayof %W] {input stdin}
  365.         %W see insert
  366.         }
  367.     }
  368.     break
  369.     }
  370.     bind $win <Insert> {
  371.     catch {tixConsoleInsert %W [selection get -displayof %W]}
  372.     break
  373.     }
  374.     bind $win <KeyPress> {
  375.     tixConsoleInsert %W %A
  376.     break
  377.     }
  378.     foreach left {Control-b Left} {
  379.     bind $win <$left> {
  380.         if [%W compare insert == promptEnd] {
  381.         break
  382.         }
  383.         tkTextSetCursor %W insert-1c
  384.         break
  385.     }
  386.     }
  387.     foreach right {Control-f Right} {
  388.     bind $win <$right> {
  389.         tkTextSetCursor %W insert+1c
  390.         break
  391.     }
  392.     }
  393.     bind $win <Control-Up> {
  394.     %W yview scroll -1 unit
  395.     break;
  396.     }
  397.     bind $win <Control-Down> {
  398.     %W yview scroll 1 unit
  399.     break;
  400.     }
  401.     bind $win <Prior> {
  402.     %W yview scroll -1 pages
  403.     }
  404.     bind $win <Next> {
  405.     %W yview scroll  1 pages
  406.     }
  407.     bind $win <F9> {
  408.     eval destroy [winfo child .]
  409.     source $tix_library/Console.tcl
  410.     }
  411.     foreach copy {F16 Meta-w Control-i} {
  412.     bind $win <$copy> {
  413.         if {[selection own -displayof %W] == "%W"} {
  414.         clipboard clear -displayof %W
  415.         catch {
  416.             clipboard append -displayof %W [selection get -displayof %W]
  417.         }
  418.         }
  419.         break
  420.     }
  421.     }
  422.     foreach paste {F18 Control-y} {
  423.     bind $win <$paste> {
  424.         catch {
  425.             set clip [selection get -displayof %W -selection CLIPBOARD]
  426.         set list [split $clip \n\r]
  427.         tixConsoleInsert %W [lindex $list 0]
  428.         foreach x [lrange $list 1 end] {
  429.             %W mark set insert {end - 1c}
  430.             tixConsoleInsert %W "\n"
  431.             tixConsoleInvoke
  432.             tixConsoleInsert %W $x
  433.         }
  434.         }
  435.         break
  436.     }
  437.     }
  438. }
  439.  
  440. # tixConsoleInsert --
  441. # Insert a string into a text at the point of the insertion cursor.
  442. # If there is a selection in the text, and it covers the point of the
  443. # insertion cursor, then delete the selection before inserting.  Insertion
  444. # is restricted to the prompt area.
  445. #
  446. # Arguments:
  447. # w -        The text window in which to insert the string
  448. # s -        The string to insert (usually just a single character)
  449.  
  450. proc tixConsoleInsert {w s} {
  451.     if ![winfo exists .console] tixConsoleInit
  452.  
  453.     if {[.console dlineinfo insert] != {}} {
  454.     set setend 1
  455.     } else {
  456.     set setend 0
  457.     }
  458.     if {$s == ""} {
  459.     return
  460.     }
  461.     catch {
  462.     if {[$w compare sel.first <= insert]
  463.         && [$w compare sel.last >= insert]} {
  464.         $w tag remove sel sel.first promptEnd
  465.         $w delete sel.first sel.last
  466.     }
  467.     }
  468.     if {[$w compare insert < promptEnd]} {
  469.     $w mark set insert end    
  470.     }
  471.     $w insert insert $s {input stdin}
  472.     if $setend {
  473.     .console see insert
  474.     }
  475. }
  476.  
  477.  
  478.  
  479. # tixConsoleOutput --
  480. #
  481. # This routine is called directly by ConsolePutsCmd to cause a string
  482. # to be displayed in the console.
  483. #
  484. # Arguments:
  485. # dest -    The output tag to be used: either "stderr" or "stdout".
  486. # string -    The string to be displayed.
  487.  
  488. proc tixConsoleOutput {dest string} {
  489.     if ![winfo exists .console] tixConsoleInit
  490.  
  491.     if {[.console dlineinfo insert] != {}} {
  492.     set setend 1
  493.     } else {
  494.     set setend 0
  495.     }
  496.     .console insert output $string $dest
  497.     if $setend {
  498.     .console see insert
  499.     }
  500. }
  501.  
  502. # tixConsoleExit --
  503. #
  504. # This routine is called by ConsoleEventProc when the main window of
  505. # the application is destroyed.
  506. #
  507. # Arguments:
  508. # None.
  509.  
  510. proc tixConsoleExit {} {
  511.     if ![winfo exists .console] tixConsoleInit
  512.  
  513.     exit
  514. }
  515.  
  516.